home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_PICK.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-24  |  8KB  |  242 lines
  1. UNIT GS_Pick;
  2. {-----------------------------------------------------------------------------
  3.                              Item Selection Routines
  4.  
  5.        GS_Pick Copyright (c)  Richard F. Griffin
  6.  
  7.         1 January 1991
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles routines to allow display of lists and selection
  14.        of items from the list.
  15.  
  16.    Changes:
  17.  
  18. -----------------------------------------------------------------------------}
  19.  
  20. INTERFACE
  21. {$D-}
  22.  
  23. USES
  24.    Crt,
  25.    Dos,
  26.    GS_Scrn,
  27.    GS_Error,
  28.    GS_KeyI,
  29.    GS_Sort,
  30.    GS_Strng,
  31.    GS_Winfc;
  32.  
  33. function GS_Pick_Row_Item (var tabl; clth : integer;
  34.                            icnt, sitem : longint): longint;
  35. function GS_Pick_Line_Item (var tabl; clth : integer;
  36.                             icnt, sitem : longint) : longint;
  37. procedure GS_Pick_Item_Sort (var tabl; clth : integer;
  38.                              icnt : longint; ascnd : boolean);
  39.  
  40. {tabl = starting location of the array}
  41. {clth = length of entry (for a string, it is length(string)+1 to include the}
  42. {        length byte.  Recommend passing sizeof(entry) for accuracy)}
  43. {icnt = number of entries}
  44. {ascnd = boolean value for sort direction.  True for ascending sort; false for
  45.          descending.
  46. {sitem = entry number to highlight.  Can be any number form 1 to icnt.  This}
  47. {        can be used to "remember" the last item selected.  for example:    }
  48. {                                                                           }
  49. {        i := 1;                                                            }
  50. {        while i <> 0 do                                                    }
  51. {        begin                                                              }
  52. {           i := GS_Pick_Line_Item(dataarray,sizeof(dataentry),25,i);       }
  53. {           case i of                                                       }
  54. {                    .                                                      }
  55. {                    .                                                      }
  56. {                    .                                                      }
  57. {           end;                                                            }
  58. {        end;                                                               }
  59.  
  60.  
  61.  
  62. implementation
  63.  
  64. var
  65.    Sort_Tab     : GS_Sort_Objt;
  66.    txc,
  67.    bgc,
  68.    fgc,
  69.    txh,
  70.    bgh           : byte;
  71.  
  72. procedure FindColors;
  73. begin
  74.    GS_Wind_GetColors(txc,bgc,fgc,txh,bgh);
  75. end;
  76.  
  77. function GS_Pick_Row_Item (var tabl; clth : integer;
  78.                            icnt, sitem : longint): longint;
  79. var
  80.    ci, cw, ct, l : longint;
  81.    cj, cis,
  82.    cih           : longint;
  83.    lins,
  84.    wdth, fl,
  85.    x, y, k       : integer;
  86.    chrr          : char;
  87.    strng         : string[255];
  88.    z             : array [0..maxint-1] of char absolute tabl;
  89. begin
  90.    GS_KeyI_Fuc := false;
  91.    GS_Scrn_HideCursor;
  92.    FindColors;
  93.    lins := (hi(windmax)) - (hi(windmin));
  94.    wdth := ((lo(windmax)) - (lo(windmin))) + 1;
  95.    l := icnt;
  96.    ci := sitem div lins;
  97.    ci := ci * lins;
  98.    fl := sitem;
  99.    cih := 0;
  100.    cis := 1;
  101.    repeat
  102.       if ci + (lins-1) > l then ci := l - (lins-1);
  103.       if ci < 1 then ci := 1;
  104.       if (not GS_KeyI_Fuc) and (fl <= icnt) then cis := (fl - ci)+1;
  105.       cj := ci;
  106.       if ci <> cih then
  107.       begin
  108.          k := 1;
  109.          cih := ci;
  110.          while cj < ci+lins do
  111.          begin
  112.             if cj <= l then
  113.             begin
  114.                y := k;
  115.                x := 2;
  116.                gotoxy(x,y);
  117.                move(z[((cj-1)*(clth))],strng[0],clth);
  118.                fillchar(strng[length(strng)+1],clth-length(strng),' ');
  119.                strng[0] := chr(clth);
  120.                write(strng);
  121.                inc(cj);
  122.                inc(k);
  123.             end else cj := 9999;
  124.          end;
  125.          gotoxy(1,lins+1);
  126.          if cj-1 < l then write('':(wdth-10) div 2,'-- more --')
  127.             else write('':wdth-1);
  128.       end;
  129.       GS_Scrn_Put_Atr(1,cis,wdth,cis,txh,bgh);
  130.       chrr := GS_KeyI_GetKey;
  131.       GS_Scrn_Put_Atr(1,cis,wdth,cis,txc,bgc);
  132.       if GS_KeyI_Fuc then
  133.       begin
  134.          case chrr of
  135.             Kbd_Home : begin
  136.                         ci := 1;
  137.                         cis := 1;
  138.                      end;
  139.             Kbd_End  : begin
  140.                           ci := l;
  141.                           cis := lins;
  142.                        end;
  143.             Kbd_PgUp : begin
  144.                           ci := ci - lins;
  145.                        end;
  146.             Kbd_PgDn : begin
  147.                           ci := ci + lins;
  148.                        end;
  149.             Kbd_UpAr : begin
  150.                           if cis = 1 then ci := ci - 1 else cis := cis - 1;
  151.                        end;
  152.             Kbd_DnAr : begin
  153.                           if cis = lins then ci := ci + 1 else cis := cis + 1;
  154.                        end;
  155.             else SoundBell(BeepTime, BeepFreq);
  156.          end;
  157.          if cis > l then cis := l;
  158.       end else
  159.       begin
  160.          case chrr of
  161.             Kbd_Ret :  GS_Pick_Row_Item := ci+cis-1;
  162.             Kbd_Esc :  GS_Pick_Row_Item := 0;
  163.             else
  164.                begin
  165.                   fl := 1;
  166.                   while (z[((fl-1)*(clth))+1] <> chrr) and
  167.                         (z[((fl-1)*(clth))+1] <> upcase(chrr)) and
  168.                         (fl <= icnt) do inc(fl);
  169.                   if fl <= icnt then ci := fl
  170.                      else SoundBell(BeepTime, BeepFreq);
  171.                end;
  172.          end;
  173.       end;
  174.    until chrr in [Kbd_Ret,Kbd_Esc];
  175.    GS_Scrn_ShowCursor;
  176. end;
  177.  
  178. function GS_Pick_Line_Item (var tabl; clth : integer;
  179.                             icnt, sitem : longint) : longint;
  180. var
  181.    ci,
  182.    x, y, k, l    : integer;
  183.    chrr          : char;
  184.    strng         : string[255];
  185.    z             : array [0..maxint-1] of char absolute tabl;
  186. begin
  187.    GS_Scrn_HideCursor;
  188.    FindColors;
  189.    l := icnt;
  190.    y := 1;
  191.    ci := succ(pred(sitem)*clth);
  192.    if ci > l*clth then ci := ((l-1)*clth)+1;
  193.    if ci < 1 then ci := 1;
  194.    repeat
  195.       k := 1;
  196.       while k <= l do
  197.       begin
  198.          x := ((k-1) * clth)+1;
  199.          gotoxy(x,y);
  200.          move(z[((k-1)*(clth))],strng[0],clth);
  201.          if length(strng) > pred(clth) then
  202.             ShowError(851,'Error in GS_Pick_Line_Item Length');
  203.          fillchar(strng[length(strng)+1],clth-length(strng),' ');
  204.          strng[0] := chr(pred(clth));
  205.          write(strng);
  206.          inc(k);
  207.       end;
  208.       GS_Scrn_Put_Atr(ci,y,ci+clth-1,y,txh,bgh);
  209.       chrr := GS_KeyI_GetKey;
  210.       GS_Scrn_Put_Atr(ci,y,ci+clth-1,y,txc,bgc);
  211.       if GS_KeyI_Fuc then
  212.       begin
  213.          case chrr of
  214.             Kbd_Home :  ci := 1;
  215.             Kbd_LfAr :  ci := ci - clth;
  216.             Kbd_RtAr :  ci := ci + clth;
  217.             Kbd_End  :  ci := ((l-1) * clth) + 1;
  218.          end;
  219.          if ci > l*clth then ci := 1;
  220.          if ci < 1 then ci := ((l-1)*clth)+1;
  221.       end;
  222.    until chrr in [Kbd_Ret,Kbd_Esc];
  223.    if chrr = Kbd_Ret then
  224.    begin
  225.       GS_Pick_Line_Item := (ci div clth) + 1 ;
  226.    end else GS_Pick_Line_Item := 0;
  227.    GS_Scrn_ShowCursor;
  228. end;
  229.  
  230. procedure GS_Pick_Item_Sort (var tabl; clth : integer;
  231.                              icnt : longint; ascnd : boolean);
  232. begin
  233.    if icnt > 1 then
  234.    begin
  235.       Sort_Tab.SortDir(ascnd);
  236.       Sort_Tab.Sort(tabl,clth,icnt);
  237.    end;
  238. end;
  239.  
  240. begin
  241.    Sort_Tab.InitSort(true);           {Init ascending sort object)}
  242. end.